PT2D.OLD[MSS,LCS] - www.SailDart.org

perm filename PT2D.OLD[MSS,LCS] blob sn#258838 filedate 1977-01-23 generic text, type C, neo UTF8
COMMENT ⊗   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002		SUBROUTINE PT2
C00019 ENDMK
C⊗;
	SUBROUTINE PT2
	INTEGER VALID
	DIMENSION VALID(7),BARS(1),JBAR(1),JRN(1),MBAR(1),STFNM(1)
	DATA JLINE/250/,HX/2./,VALID/1,4,8,2,3,-2,-1/,SLSP/11.0/,DIV/4./
C  JLINE=BASIC LINE LENGTH, HX=HEIGHT MULTIPLIER, ZL=LN. LNGTH FACTOR.

C  ADD MORE TO VALID LATER ***
	COMMON /FIN/LBAR,METR,REND,KPX,KREAD,JEND,JSLUR,JSL2,NAMZ
	1,LC,LPG,MPG,CLEF,SIG,LB,SPG,MTR1,MTR2 /MNX/MIN,MAX,JT
	COMMON /SF/KL,RT,KP,STFSZ,NAMX /IPG/IPG,JPG,BRACK,
	1 RSTNUM(8),RPSZ(8),RHGT(8),RCLEF(-3/4) /KBAR/KBAR(512) 
	1 /RSP/KNM(10),ENDLN,N,NAME,NMPG,T
	COMMON RS,JA,RA,R,RB,RQ(15),KQ,NQ,JQ,JJQ,KBQ,NAQ
	COMMON/STF/RSTFAC(-3/4),RSTJ2 /IVV/IV(1) /SIZE/SIZE
	COMMON /POSI/STFF(-3/4),JJ2,JPQ /LLL/L,ITRANS,I,RXQ,XSIG
	1/PX/KPN(1) /Q/Q(1) /PTR/KWDS(1) /XRN/RN(1) /NBAR/NBAR(50)
	EQUIVALENCE (RQ(2),R4),(R5,RQ(3)),(R6,RQ(4)),(R7,RQ(5)),(KT,KBAR)
     1,(R8,RQ(6)),(R9,RQ(7)),(JRN,RN),(MBAR,RN(1000)),(STFNM,KBAR(509))
	1,(LCNT,IV(45)),(NDPY,IV(46)),(TOT,KBAR(2)),(JBAR,BARS,KBAR(4))
C  TRNSP'S Bb, F, BBb, A, G, Eb, D.
145	FORMAT(F,3I)
	IF(NAMX.NE.0)GO TO 2000
	CALL GETEXT('BARS','PAG')
	CALL EXTIN(KBAR,512)
C  STAFF NAMES BEGIN IN KBAR(508)  [STFNM(0) ]
	CALL EXTIN(RSTFAC,128)
2000	TYPE 144,RSTJ2
304	FORMAT(' TRANSP.= '$)
144	FORMAT(' STAFF SIZE='F4.2,'  CHANGE TO '$)
	ACCEPT 145,SIZE,DSK
C  TYPE 3RD NUM TO WRITE BARS/LINE DATA ON DSK FILE FOR21.DAT
	IF(DSK.NE.0)DSK=-1
	XSIG=0
	ITRANS=0
	IF(IPG.EQ.0)GO TO 1304
	TYPE 304
	ACCEPT 306,ITRANS
1304	IF(SIZE.EQ.0)SIZE=RSTJ2
	SIZE=SIZE/RSTJ2 
101	JTOT=0
	ITOT=0
CXX	BARS(1)=BARS(1)-5.0
C  ABOVE ASSUMES FIRST LINE ALWAYS HAS A CLEF.
122	DO 22 K=1,KT
	JJ=BARS(K)*SIZE+.5
	ITOT=ITOT+JJ
	JBAR(K)=JJ
22	JTOT=JTOT+JJ
	ITOT=TOT*SIZE
CC22	JBAR(K)=BARS(K)*SIZE+.5
CC	TOT=TOT*SIZE
33	IF(RSTJ2.EQ.0)RSTJ2=1 
	RA=JPG*SIZE*RSTJ2
	MPG=10./RA
C  MPG=NUM OF BRACES PER PAGE.
	RS=SIZE*17
	RA=(RSTJ2*SIZE)/RPSZ(1)
	DO 141 K=1,JPG
	RB=RSTNUM(K)-1
C  ADJUSTS DIST. BETWEEN STAVES DEPENDING ON SIZE FACTOR.
	RHGT(K)=RHGT(K)+RB*(RS-17)
141	RPSZ(K)=RPSZ(K)*RA
	LPG=JPG
	IF(MOD(ITRANS,7).EQ.0)GO TO 140
	DO 40 L=1,7
40	IF(ITRANS.EQ.VALID(L))GO TO 140
	TYPE 240
	GO TO 2000
240	FORMAT(' THIS TRANSP NOT OFFERED')

140	TYPE 90,KT
	RA=0
90	FORMAT(' TOTAL BAR LINES='I3/' NUMBER OF BARS PER LINE')
	
	JT=ITOT/JLINE
C  USE JLINE (250 FOR NOW) AS SUGGESTED LINE LENGTH
16	NT=JT
	L=0
CC	JTOT=TOT+.5
	KTOT=JTOT
	KAV=JTOT/JT

	LMIN=-1
	LMAX=10000
	LJ=0
	NJ=0
	LMM=-1
	LDIF=10000
	NBAR(1)=1
	J=1
3	M=1
	JAV=KTOT/NT
	K=JBAR(J)
1	J=J+1
	IF(J.GT.KT)GO TO 2
	N=JBAR(J)
	IF(K+N/2.GE.JAV)GO TO 2
	M=M+1
	K=K+N
	GO TO 1
2	L=L+1
	KTOT=KTOT-K
	NT=NT-1
	JRN(L)=K
	NBAR(L+1)=J
	IF(NT.GT.0)GO TO 3
5	MAX=0
	MIN=10000

	DO 7 L=1,JT
	K=JRN(L)
	IF(K.LE.MAX)GO TO 6
	MAX=K
	MX=L
6	IF(K.GE.MIN)GO TO 7
	MIN=K
	MN=L
7	CONTINUE

	J=MAX-MIN
	IF(MAX.GE.LMAX.AND.J.GE.LDIF)GO TO 9
	IF(MIN.GT.LMIN)LMIN=MIN
	IF(MAX.LT.LMAX)LMAX=MAX
	IF(J.LT.LDIF)LDIF=J
	CALL RLOOP(MBAR(2),NBAR(2),JT)
C  SAVE NBAR INFO IN MBAR

	IF(MX.LT.MN)GO TO 32
	IF(MX.LE.1)GO TO 5
	JJ=0
	JM=-1
	JK=1
23	K=NBAR(MX+JJ)-JJ
C NEXT RIPPLES THE BARS, FROM MAX TO MIN.
	MM=JBAR(K)
	JRN(MX)=JRN(MX)-MM
	JMX=JM+MX
	JRN(JMX)=JRN(JMX)+MM
	NBAR(MX+JJ)=K+JK
	MX=JMX
	IF(JJ.NE.0)GO TO 223
	IF(MX.GT.MN)GO TO 23
	GO TO 5 
223	IF(MX.LT.MN)GO TO 23
	GO TO 5 
32	JJ=1
	JM=1
	JK=0
	GO TO 23
9	CALL GET
	IDIF=10000
	JJT=JT-1
104	CALL MNMX(IDIF)
108	DO 102 J=1,JJT
	IF(JRN(J).LE.KAV)GO TO  102
C DON'T MAKE IT SMALLER IF IT'S ALREADY LESS THAN AVERAGE.
	I=NBAR(J+1)-1
	IF(I.EQ.NBAR(J))GO TO 102
C WE'RE DOWN TO ONE BAR
	JJ=JRN(J)-JBAR(I)
C SUBTRACT LAST BAR OF THIS LINE, ADD IT ON NEXT.
	IF(JJ.LT.MIN)GO TO 102
	KK=JRN(J+1)+JBAR(I)
	IF(KK.GT.MAX)GO TO 103
C LET'S SEE IF FURTHER SHUFFLING WILL IMPROVE IT.
	CALL MINMAX
105	JRN(J)=JJ
	JRN(J+1)=KK
	NBAR(J+1)=NBAR(J+1)-1
	GO TO 104
103	IF(J.EQ.JJT)GO TO 102
	NN=KK
	DO 106 K=J+1,JJT
	LL=NBAR(K+1)-1
C CHECK ON WHAT WILL HAPPEN TO NEXT LINE.
	MM=NN-JBAR(LL)
	IF(MM.LT.MIN.OR.MM.GT.MAX)GO TO 102
	NN=JBAR(LL)+JRN(K+1)
106	IF(NN.LE.MAX)GO TO 105
102	CONTINUE
204	CALL MNMX(IDIF)
208	DO 202 J=JT,2,-1
	IF(JRN(J).LE.KAV)GO TO  202
C DON'T MAKE IT SMALLER IF IT'S ALREADY LESS THAN AVERAGE.
	I=NBAR(J)
	IF(I-1.EQ.NBAR(J-1))GO TO 202
C WE'RE DOWN TO ONE BAR
	JJ=JRN(J)-JBAR(I)
C SUBTRACT LAST BAR OF THIS LINE, ADD IT ON NEXT.
	IF(JJ.LT.MIN)GO TO 202
	KK=JRN(J-1)+JBAR(I)
	IF(KK.GT.MAX)GO TO 203
C LET'S SEE IF FURTHER SHUFFLING WILL IMPROVE IT.
	CALL MINMAX
205	JRN(J)=JJ
	JRN(J-1)=KK
	NBAR(J)=NBAR(J)+1
	GO TO 204
203	IF(J.EQ.2)GO TO 202
	NN=KK
	DO 206 K=J-1,2,-1
	LL=NBAR(K)
C CHECK ON WHAT WILL HAPPEN TO NEXT LINE.
	MM=NN-JBAR(LL)
	IF(MM.LT.MIN.OR.MM.GT.MAX)GO TO 202
	NN=JBAR(LL)+JRN(K-1)
206	IF(NN.LE.MAX)GO TO 205
202	CONTINUE

	CALL MINMAX
	IDIF=MAX-MIN
	CALL RLOOP(MBAR(2),NBAR(2),JT)
400	MX=MAX+5
	JR=1
C  JR = HOW MANY BARS TO RIPPLE
	I=MAX-MIN
	IF(I.GT.IDIF)GO TO 402
	CALL RLOOP(MBAR(2),NBAR(2),JT)
	IDIF=I
402	DO 401 J=1,JT
401	IF(JRN(J).EQ.MIN)GO TO 408
C  TRY RIPPLE EACH WAY FROM SMALLEST VALUE
408	IF(J.EQ.JT)GO TO 508
C RIPPLE FORWARD FIRST
	I=NBAR(J+1)
	JJ=JRN(J)+JBAR(I)
	IF(JJ.GT.MX)GO TO 508
C SMALLEST ISN'T TOO BIG, NOW CHECK UP THE LINE.
	NN=JRN(J+1)-JBAR(I)
	IF(NN.LT.MIN)GO TO 404
C IF WE GET HERE THERE HAS BEEN IMPROVEMENT
	JRN(J)=JJ
	JRN(J+1)=NN
	NBAR(J+1)=I+1
415	CALL MINMAX
C NOW GO BACK AND TRY AGAIN.
	GO TO 400

405	JRN(J)=JJ

	DO 422 IB=J+1,N
	LB=NBAR(IB)
	JB=JRN(IB)-JBAR(LB)
	NBAR(IB)=LB+1
	IF(JB.LT.MIN)GO TO 421
	JRN(IB)=JB
	GO TO 415

421	IBB=IB+1
	LC=NBAR(IBB)
	JB=JB+JBAR(LC)
	IF(JB.GT.MIN)GO TO 422
C NOW ADD A SECOND BAR
	JRN(IBB)=JRN(IBB)-JBAR(LC)
	LC=LC+1
	JB=JB+JBAR(LC)
	NBAR(IBB)=LC

422	JRN(IB)=JB
	NBAR(IBB)=LC+1
	JRN(IBB)=JRN(IBB)-JBAR(LC)
	GO TO 415
C NOW GO BACK AND TRY AGAIN.
	
404	IF(J.EQ.JJT)GO TO 508
	DO 406 N=J+1,JJT
  	LL=NBAR(N+1)
	MM=NN+JBAR(LL)
	IF(MM.GT.MX)GO TO 508
	IF(MM.GT.MIN)GO TO 409
C NEXT TO RIPPLE 2 BARS!
412	MN=MM+JBAR(LL+1)
C  ADD ON A SECOND BAR
	IF(MN.GT.MX)GO TO 508
C DON'T WORRY ABOUT IT BEING TOO SMALL (YET)
	NN=JRN(N+1)-JBAR(LL)-JBAR(LL+1)
	IF(NN.GT.MIN)GO TO 405
	GO TO 406

409	NN=JRN(N+1)-JBAR(LL)
	IF(NN.GE.MIN)GO TO 405
406	CONTINUE

C  TRY RIPPLE EACH WAY FROM SMALLEST VALUE
508	IF(J.EQ.1)GO TO 502
	IF(J.EQ.LJ.AND.MX-MN.EQ.LMM)GO TO 502
	IF(JDIF.EQ.IDIF)GO TO 150
	ICNT=0
	GO TO 151
150	ICNT=ICNT+1
	IF(ICNT.EQ.10)GO TO 515
151	JDIF=IDIF
C THIS SHOULD AVOID GETTING INTO A LOOP
	LJ=J
	LMM=MX-MN
C RIPPLE BACK NOW
	I=NBAR(J)-1
	JJ=JRN(J)+JBAR(I)
	IF(JJ.GT.MX)GO TO 502
C SMALLEST ISN'T TOO BIG, NOW CHECK UP THE LINE.
	NN=JRN(J-1)-JBAR(I)
	IF(NN.LT.MIN)GO TO 504
C IF WE GET HERE THERE HAS BEEN IMPROVEMENT
	JRN(J)=JJ
	JRN(J-1)=NN
	NBAR(J)=I
	GO TO 415
505	JRN(J)=JJ
	DO 522 IB=J-1,N,-1
	LB=NBAR(IB+1)-1
	JB=JRN(IB)-JBAR(LB)
	NBAR(IB+1)=LB
	IF(JB.LT.MIN)GO TO 521
	JRN(IB)=JB
	GO TO 415
521	IBB=IB-1
	LC=NBAR(IB)-1
	JB=JB+JBAR(LC)
	IF(JB.GT.MIN)GO TO 522
	JB=JB+JBAR(LC-1)
	NBAR(IB)=LC
	JRN(IBB)=JRN(IBB)-JBAR(LC)
CHECK THIS OUT!!
	LC=LC-1
522	JRN(IB)=JB
	JRN(IBB)=JRN(IBB)-JBAR(LC)
	NBAR(IB)=LC
	GO TO 415
504	IF(J.LE.2)GO TO 502
	DO 506 N=J-1,2,-1
 	LL=NBAR(N)-1
	MM=NN+JBAR(LL)
	IF(MM.GT.MX)GO TO 502
	IF(MM.GT.MIN)GO TO 509
512	MN=MM+JBAR(LL-1)
	IF(MN.GT.MX)GO TO 502
	NN=JRN(N-1)-JBAR(LL)-JBAR(LL-1)
	IF(NN.GT.MIN)GO TO 505
	GO TO 506
509	NN=JRN(N-1)-JBAR(LL)
	IF(NN.GE.MIN)GO TO 505
506	CONTINUE
502	IF(J.EQ.NJ.AND.MX-MN.EQ.LMM)GO TO 515
C  CHECK TO AVOID ENDLESS LOOP.
	NJ=J
	IF(J.EQ.JT)GO TO 515
C LOOK FOR OTHER LINES = MIN.
	DO 510 K=J+1,JT
	IF(JRN(K).NE.MIN)GO TO 510
	J=K
	GO TO 408
510	CONTINUE

515	CALL GET

13	DO 14 L=2,JT
	K=NBAR(L)
	MM=JRN(L)
	KK=JRN(L-1)
	IF(MM.GE.KK)GO TO 12
C  JUGGLES ADJACENT LINES
	N=JBAR(K-1)
	IF(KK-MM.LT.N)GO TO 14
	JRN(L-1)=KK-N
	JRN(L)=MM+N
	NBAR(L)=K-1
	GO TO 13
12	N=JBAR(K)
	IF(MM-KK.LE.N)GO TO 14
	JRN(L-1)=KK+N
	JRN(L)=MM-N
	NBAR(L)=K+1
	GO TO 13
14	CONTINUE
46	J=1
	NBAR(JT+1)=KT+1
	JAV=JTOT/JT
	CALL MINMAX
	TYPE 308,JAV,MIN,MAX
	IF(DSK)WRITE(21,308)JAV,MIN,MAX
307	DO 305 K=1,JT
	NBAR(K)=NBAR(K+1)-NBAR(K)
C NBAR NOW HAS NUM. OF BARS PER LINE.
	L=NBAR(K)-1+J
308	FORMAT(' AVG=',I3,'  MIN=',I3,'  MAX=',I3)
306	FORMAT(I5,3X8I5)
	TYPE 306,JRN(K),(JBAR(N),N=J,L)
	IF(DSK)WRITE(21,306)JRN(K),(JBAR(N),N=J,L)
305	J=L+1
	NBAR(JT+1)=0
	
	RPG=JT
	RPG=RPG/MPG
605	TYPE 604,RPG,JT
	IF(DSK)WRITE(21,104)RPG,JT
604	FORMAT(F5.2,' PAGES',/,I4,' LINES - OR TYPE N1, N2 --'$)
C  FOR SPECIFICATION OF HOW MANY BARS ON EACH LINE
	KA=0
C FOR 'T' TYPE X.Y FOR X PAGES, Y LINES PER PAGE.( .05=5 LINES, .10=10 ETC.)
	ACCEPT 145,T,N,KL
C   TYPE 0,n  TO EXIT WITH n SPACING BETWEEN STAVES (2 IS DEFAULT)
	IF(KL.NE.0)GO TO 110
C NO MORE THAN 50 NUMS, INCLUDING 0S (FOR PAGE MARKS)
	IF(T.EQ.0)GO TO 11
	JT=T
	IF(T.EQ.JT)GO TO 210
	MPG=(T-JT)*100
 	JT=JT*MPG
210	IF(N.EQ.0)GO TO 16
C N=0 MEANS T= NUM OF LINES DESIRED.

111	FORMAT(50I)
110	REREAD 111,NBAR
911	DO 112 K=50,1,-1
	KP=NBAR(K)
	KA=KA+KP
112	IF(KP.EQ.0.AND.KA.EQ.0)KL=K
	IF(KA.NE.KT)GO TO 605
C  MISMATCH!
	N=26-2*MOD(KL-1,12)
	IF(N.EQ.26)N=0
C  TO SPACE OUT STAVES VERTICALLY

11	SPG=10./MPG
C  MPG=NUM OF BRACES PER PAGE.
C  SPG IS SPACE TO BE SET ABOVE STAFF 0
	CALL WRTPAG
	END

CC	SUBROUTINE MINMAX
CC	COMMON /MNX/MIN,MAX,JT /XRN/JRN(1)
CC	MIN=10000
CC	MAX=0
CC	DO 107 K=1,JT
CC	NN=JRN(K)
CC	IF(NN.LT.MIN)MIN=NN
CC107	IF(NN.GT.MAX)MAX=NN
CC	END

CC	SUBROUTINE STORE
CC	COMMON /MNX/MIN,MAX,JT /XRN/JRN(1)/NBAR/NBAR(1)
CC	DIMENSION MB(1)
CC	EQUIVALENCE (MB,JRN(1000))
CC	DO 1 K=2,JT+1
CC1	MB(K)=NBAR(K)
CC	END

	SUBROUTINE GET
	COMMON /MNX/MIN,MAX,JT /XRN/JRN(1)/NBAR/NBAR(1)/KBAR/KBAR(1) 
	DIMENSION MB(1),JBAR(1)
	EQUIVALENCE  (MB,JRN(1000)),(JBAR,KBAR(4))
	J=1
	DO 1 K=2,JT+1
	NBAR(K)=MB(K)
	N=0
	DO 2 L=J,MB(K)-1
C FIX UP JRN ARRAY
2	N=N+JBAR(L)
	JRN(K-1)=N
1	J=MB(K)
	END

CC	SUBROUTINE MNMX(IDIF)
CC	COMMON /MNX/MIN,MAX,JT /XRN/JRN(1)
CC	L=MIN
CC	N=MAX
CC	CALL MINMAX
CC	J=MAX-MIN
CC	IF(J.LE.IDIF)GO TO 1
CC	MIN=L
CC	MAX=N
CC	RETURN
CC1	IDIF=J
CC	END